CD Actual 9/CDACTUAL9.iso/share/Dos/VARIOS/pascal/SWAG9605.DDD/0131_Inbound scanning utility.pas

Pascal/Delphi Source File | 1996-05-31 | 14.7 KB | 432 lines

{
(BTW: it requires a 386 or up to run). It should be
(almost) bug free, since my boss has been running it for about a month by now
and all problems he has found have been fixed.
------------- BBSCAN.PAS -------------------
}
Program bbscan;

{$g+,a+,q-,r-,i-,q-,s-,n-,e-,x+,f-}

Uses crt, dos;

Const l = 20; {maxlength of areanames, limit of Squish statistics tools}
      maxareas = (65504-2) div (l+1); {around 3000}

Type areaarray = Record
                         nofareas: Word;
                         area: Array[0..maxareas] of String[l]
                   End;

Const ProgName = 'BackboneScan v1.14, Copyright (c) Gamefreak 1996';
      fs = $64;
      pop_fs = $a10f;
      Fidoexists: Boolean = true;

VAR fido, bb, newfido: TEXT;
    areas: ^areaarray;
    c1, c2: Word;
    tempstr: String;
    Asort: Array[0..maxareas] of Word;

PROCEDURE Init;
VAR iocheck: Integer;
    f: file;
BEGIN
     ClrScr;
     WRITELN(ProgName);
     WRITELN;
     Assign(f, 'backbone.in');
    {$i-}
     Reset(f);
    {$i+}
     iocheck := ioresult;
     IF iocheck <> 0 THEN
     CASE iocheck OF
          2,3: BEGIN
               WRITELN('File "backbone.in" not found. Please move this program into the right dir');
               WRITELN('and run it again.');
               WRITELN;
               HALT(iocheck)
               END
             ELSE
               BEGIN
               WRITELN('An error (',iocheck,') occurred while opening the file "fidonet.na".');                    WRITELN;
               HALT(iocheck)
               END
     END;
     IF FileSize(f) = 0 THEN
     BEGIN
          WRITELN('Size of file "backbone.in" = 0 bytes. Nothing to do.');
          WRITELN;
          HALT(1)
     END;
     close(f);
     assign(f, 'fidonet.na');
    {$i-}
     reset(f);
    {$i+}
     If ioresult <> 0 Then
        Begin
             rewrite(f);
             fidoexists := false
        End
      Else if filesize(f) = 0 Then fidoexists := false;
     close(f);
     Assign(fido, 'fidonet.na');
     reset(fido);
     Assign(bb, 'backbone.in');
     Reset(bb)
END;

PROCEDURE ReadAreaNames;
Var tempstr2: String[12+30];

Function Duplicate: Boolean;
Assembler;
        Asm
           cld
           les di, areas
           mov dx, [es:di]      {dx = nofareas}
           xor al, al
           test dx, dx
           jz @end
           add di, 2            {es:di = 1st string}
           xor cx, cx
           mov si, offset tempstr {ds:si points to tempstr}
           mov bl, [si]         {bx = length(tempstr)}
           mov bh, bl
           and bh, 11b          {bh = length(tempstr) mod 4}
           shr bl, 2            {bl = length(tempstr) div 4}
           mov ax, di           {save di in ax}
          @loop:
           mov cl, bl           {cl = length(tempstr) div 4}
           xor ch, ch
           db $66; repe cmpsw   {compare}
           jne @ok              {not equal? -> ok}
           mov cl, bh           {otherwise check remaining bytes}
           repe cmpsb
           je @equal
          @ok:
           mov si, offset tempstr {ds:si points to tempstr}
           add ax, l + 1           {let ax point to next string}
           mov di, ax           {and move it into si}
           dec dx               {decrease the number of areas}
           jnz @loop            {if not zero -> loop}
           xor al, al           {no equal string -> false}
           jmp @end
          @equal:
           mov al, 1            {equal -> true}
          @end:
END;

BEGIN
     WRITELN('Reading areanames from "Backbone.in" and removing duplicates...');
     WRITELN;
     IF maxavail < 65535 THEN
        BEGIN
             WRITELN('Not enough memory available.');
             WRITELN;
             close(bb);
             close(fido);
             HALT(8)
        END
         ELSE new(areas);
     fillchar(areas^, sizeof(areas^), 0);
     While (areas^.nofareas < maxareas) and not(eof(bb)) Do
           BEGIN
                Readln(bb, tempstr);
                ASM
                   cld                       {this part copies the areaname}
                   push ds                   {to the front of the string}
                   mov di, offset tempstr    {and removes the "xxx messages}
                   mov dx, di                {scanned/tossed" part.}
                   mov si, di
                   add si, 12
                   pop es                    {es:di = sortstr[0]}
                   xor cx, cx
                   mov al, ' '               {used to check length of areaname}
                   mov cl, byte[di]          {cl = length total string}
                   add di, 12                {es:di = sortstr[12]}
                   sub cl, 12
                   mov bx, cx                {save original length - 12}
                   dec bx
                   repne scasb                {scan until a space is encouterd-> eof areaname}
                   sub bx, cx                {calc length of areaname}
                   mov cx, bx                {move length(areaname in cx)}
                   mov di, dx
                   mov [di], cl              {move length of areaname in lengthbyte}
                   inc di                    {points to first char of string}
                   shr cx, 1
                   jnc @even
                   movsb
                  @even:
                   rep movsw                 {move the areaname to the front}
                END;
                If not(duplicate) Then
                   With areas^ Do
                        BEGIN
                             area[nofareas] := tempstr;
                             inc(nofareas)
                        END
           END;
           Dec(areas^.nofareas);
           close(bb)
END;

Procedure Sort;
Var areasofs: Word;
Begin
     Writeln('Sorting areanames...');
     Writeln;
     Asm
        push ds
        push ds
        dw pop_fs
        cld
        les di, areas
        mov dx, word[es:di]
        mov bx, dx
        add bx, bx
        add bx, offset asort
       @asortinit:
        mov [bx], dx
        sub bx, 2
        dec dx
        jnz @asortinit
        mov dx, [es:di]
        dec dx
        jl @end
        mov ax, dx        {ax = pred(areas^.nofareas)}
        xor dx, dx
        lds si, areas
        add si, 3
        mov areasofs, si
        xor bx, bx        {bx = c2}
       @outloop:
        mov di, areasofs
        db fs; mov cx, [bx+offset asort+2]
        add di, cx
        shl cx, 2
        add di, cx
        shl cx, 2
        add di, cx
       @loop:
        mov si, areasofs
        db fs; mov cx, [bx+offset asort]
        add si, cx
        shl cx, 2
        add si, cx
        shl cx, 2
        add si, cx
        xor cx, cx
        mov cl, [si-1]
        cmp cl, [di-1]
        jbe @length_ok
        mov cl, [di-1]
       @length_ok:        {cl = length of shortest string}
        push si
        push di
        rep cmpsb         {compare the strings}
        pop si            {si = pushed di and di = pushed si, used so I}
        pop di            {have to recalculate di in the next loop}
        jb @noswitch      {if first < second, don't switch}
        ja @switch        {if first > second, switch}
                          {if the prog gets here, the compared part was equal}
                          {so the longest string is the greatest}
        mov cl, [di-1]    {get length of first string (di has been switched}
                          {with si)}
        cmp cl, [si-1]    {compare with length of second string}
        jbe @noswitch     {length(string 1) < length(string 2) -> no switch}
       @switch:
        mov di, si
        db fs; db $66; ror word[bx+offset asort], 16
       @noswitch:
        sub bx,2          {decrease c2}
        jns @loop         {if above or equal 0 then loop}
        inc dx            {increase c1}
        mov bx, dx        {c2 = c1}
        add bx, bx
        cmp dx, ax        {compare c1 with pred(areas^.nofareas)}
        jbe @outloop      {if below or equal, loop}
       @end:
        pop ds
     End
End;

Procedure Update;
Const days : array [0..6] of String[9] =
           ('Sunday','Monday','Tuesday',
            'Wednesday','Thursday','Friday',
            'Saturday');
            areasstillactive: Word = 0;
            areasactivated: Word = 0;
            areasstillnoflow: Word = 0;
            areasnoflow: Word = 0;
            newareascount: Word = 0;

Var tempstr2: String;
    logfile: Text;
    dofw, d, m, y: Word;
    h,min,s: String[2];
    Newareas: Array[0..maxareas] of Word;
Begin
     Writeln('Writing new "Fidonet.na"...');
     Writeln;
     Assign(newfido, 'Newfido.na');
     Rewrite(NewFido);
     Assign(logfile, 'bbscan.log');
    {$i-}
     Append(logfile);
    {$i+}
     IF ioresult <> 0 Then Rewrite(logfile);
     If fidoexists Then
       Begin
         Readln(fido,tempstr);
         For c1 := 0 to areas^.nofareas Do
           Begin
              While ((tempstr < areas^.area[asort[c1]]) and not(eof(fido))) Do
                    Begin
                         If length(tempstr) <= l Then
                            Begin
                            Fillchar(tempstr[succ(length(tempstr))], l-length(tempstr), #$20);
                            tempstr[0] :=char(l);
                            tempstr := concat(tempstr, '[FiDo] No description available yet.')
                            End;
                         If tempstr[l+7] = ' ' Then
                            Begin
                                 inc(areasstillnoflow)
                            end
                          Else
                           Begin
                                inc(areasnoflow);
                                tempstr[l+7] := ' '
                           End;
                         Writeln(NewFido, tempstr);
                         ReadLn(fido, tempstr)
                    End;
              ASM
                 cld               {This part copies the areaname out of}
                 push ds           {tempstr to tempstr2.}
                 lea di, tempstr
                 pop es
                 mov al, ' '
                 xor bx, bx
                 mov bl, [es:di]
                 cmp bl, l+1
                 ja @length_ok
                 inc bl
                 mov [es:di+bx], al
                @length_ok:
                 inc di
                 mov cx, l+1
                 mov bx, l
                 repne scasb
                 sub bx, cx
                 push ss
                 mov cx, bx
                 lea si, tempstr+1
                 pop es
                 lea di, tempstr2
                 mov [es:di], cl
                 inc di
                 shr cx, 1
                 jnc @even
                 movsb
                @even:
                 rep movsw
              END;
              If tempstr2 = areas^.area[asort[c1]] Then
                 Begin
                      If length(tempstr) <= l Then
                         Begin
                              Fillchar(tempstr[succ(length(tempstr))],l-length(tempstr), #$20);
                              tempstr[0] := char(l);
                              tempstr := concat(tempstr, '[FiDo]*No description available yet.')
                              End;
                      If tempstr[l+7] = '*' Then inc(areasstillactive)
                         Else
                             Begin
                               tempstr[l+7] := '*';
                               inc(areasactivated)
                             End;
                      Writeln(NewFido, tempstr);
                      Readln(fido,tempstr)
                 End
               Else
                   Begin
                        newareas[newareascount] := c1;
                        inc(newareascount);
                        tempstr2 := areas^.area[asort[c1]];
                        For c2 := 1 to (l-length(areas^.area[asort[c1]])) Do
                            tempstr2 := concat(tempstr2,' ');
                        tempstr2 := concat(tempstr2, '[FiDo]*New added area. No description available yet.');
                        WriteLn(newfido,tempstr2)
                        End
           End
       End
      Else
         With areas^ Do
          Begin
              For c1 := 0 to nofareas Do
                  Begin
                       tempstr2 := area[asort[c1]];
                       For c2 := 1 to (l-length(area[asort[c1]])) Do
                            tempstr2 := concat(tempstr2,' ');
                        tempstr2 := concat(tempstr2, '[FiDo]*New added area. No description available yet.');
                        WriteLn(newfido,tempstr2)
                        End
       End;
     If fidoexists Then Writeln('"Fidonet.na" has been successfully updated!')
                    Else Writeln('"Fidonet.na" has been successfully created!');
                    Writeln;
     Writeln('Updating logfile (bbscan.log)...');
     Writeln;
     Getdate(y, m, d, dofw);
     Write(logfile,'---------- ',days[dofw],', ', d:0,'/',m:0,'/',y:0,', ');
     Gettime(y, m, d, dofw);
     str(y,h);
     str(m,min);
     str(d,s);
     If length(h) = 1 Then h := concat('0',h);
     If length(min) = 1 Then min := concat('0',min);
     If length(s) = 1 Then s := concat('0',s);
     Writeln(logfile, h,':',min,':',s,'.');
     If (newareascount > 0) Then
             Begin
                  Writeln(logfile, 'New Areas:');
                  For c1 := 0 to pred(newareascount) Do
                      Begin
                           Write(logfile, areas^.area[asort[newareas[c1]]]:38);
                           If (succ(c1) mod 2 = 0) Then Writeln(logfile)
                           End
             End;
     If (succ(c1) mod 2 <> 0) Then Writeln(logfile);
     Writeln(logfile);
     If not(fidoexists) Then newareascount := areas^.nofareas;
     Writeln(logfile, 'Amount of new areas:   ',newareascount);
     Writeln(logfile, 'Areas still active:    ',areasstillactive,'.');
     Writeln(logfile, 'Areas activated:       ',areasactivated,'.');
     Writeln(logfile, 'Areas still down:      ',areasstillnoflow,'.');
     Writeln(logfile, 'Areas deactivated:     ',areasnoflow,'.');
     Writeln(logfile, 'Total number of areas:',newareascount+areasstillactive+areasactivated+areasstillnoflow+areasnoflow,'.');
     Writeln(logfile);
     close(logfile);
     close(newfido);
     close(fido);
    {$i-}
     assign(logfile, 'fidonet.bak');
     Erase(logfile);
     rename(fido, 'fidonet.bak');
     rename(newfido, 'fidonet.na')
    {$i+}
End;

Begin
     Init;
     ReadareaNames;
     sort;
     update
END.